home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-19 / feb93.zip / TIP847B.LSP < prev    next >
Lisp/Scheme  |  1993-01-14  |  1KB  |  39 lines
  1. ;TIP847B: TUBENDS.LSP (C)1993, CAREY T. WALDROP
  2.  
  3. (defun C:TUBENDS ()
  4.   (COMMAND "LIMITS" "OFF")
  5.   (setvar "flatland" 0)
  6.   (graphscr)
  7.   (setvar "cmdecho" 0)
  8.   (setvar "splframe" 1)
  9.   (setq p1 (getpoint "\ncenter of tube? "))(terpri)
  10.   (setq nf (getstring "\nnumber of 3d faces? "))(terpri)
  11.   (setq dia (getreal "\ndiameter of tube? "))(terpri)
  12.   (setq length (getstring "\nlength of tube? "))(terpri)
  13.   (setq L1 (atof length))
  14.   (setq r (/ dia 2.0))
  15.   (setq alpha (/ 360.0 (atof nf)))
  16.   (setq ang (/ alpha 2.0))
  17.   (setq PT1 (polar p1 (* pi (/ alpha 180.0)) r))
  18.   (setq PT2 (list (car PT1) (cadr PT1) (- (caddr PT1) L1)))
  19.   (setq PT4 (polar p1 0.0 r))
  20.   (setq PT3 (list (car PT4) (cadr PT4) (- (caddr PT4) L1)))
  21.   (setq PT5 (list (car p1) (cadr p1) (caddr PT1)))
  22.   (setq PT6 (list (car p1) (cadr p1) (- (caddr PT1) L1)))
  23.   (command "3dface" PT1 "i" PT2 "i" PT3 "i" PT4 "")
  24.   (setq z1 (list (- (car p1) 2) (- (cadr p1) 2)))
  25.   (setq z2 (list (+ (car p1) 2) (+ (cadr p1) 2)))
  26.   (command "zoom" "w" z1 z2)
  27.   (setq ss1 (ssget "L"))
  28.   (command "rotate" ss1 "" p1 ang)
  29.   (command "array" "L" "" "P" p1 nf 360.0 "Y")
  30.   (command "3dface" PT4 "i" PT1 "i" PT5 "" "")
  31.   (setq ss2 (ssget "L"))
  32.   (command "rotate" ss2 "" p1 ang)
  33.   (command "array" ss2 "" "P" p1 nf 360.0 "Y")
  34.   (command "zoom" "p")
  35.   (command "copy" ss2 "" PT5 PT6)
  36.   (command "array" "L" "" "P" p1 nf 360.0 "Y")
  37.   (COMMAND "LIMITS" "ON")
  38. )
  39.